home *** CD-ROM | disk | FTP | other *** search
/ PC Open 107 / PC Open 107 CD 1.bin / CD1 / INTERNET / COPIA SITI / Getleft / getleft-setup-notcl.exe / {app} / scripts / HtmlParser.tcl < prev    next >
Encoding:
Text File  |  2004-03-09  |  22.7 KB  |  708 lines
  1. ###############################################################################
  2. ###############################################################################
  3. #                               HtmlParser.tcl
  4. ###############################################################################
  5. ###############################################################################
  6. # In this file are implemented the procedures used to parse Html file links.
  7. ###############################################################################
  8. ###############################################################################
  9. # Copyright 2000-2004 AndrΘs Garcφa Garcφa  -- fandom@retemail.es
  10. # Distributed under the terms of the GPL v2
  11. ###############################################################################
  12. ###############################################################################
  13. namespace eval HtmlParser {
  14.  
  15. ###############################################################################
  16. # SetEntities
  17. #    Initializes the arrays with the translation for Html entities, something
  18. #    like 'entity(lt)==>'
  19. ###############################################################################
  20. proc SetEntities {} {
  21.     variable entities
  22.  
  23.     set entities(quot)      \"
  24.     set entities(amp)       \\&
  25.     set entities(lt)        <
  26.     set entities(gt)        >
  27.     set entities(nbsp)      {}
  28.     set entities(iexcl)     í
  29.     set entities(cent)      ó
  30.     set entities(pound)     ú
  31.     set entities(curren)    ñ
  32.     set entities(yen)       Ñ
  33.     set entities(brvbar)    \|
  34.     set entities(sect)      º
  35.     set entities(uml)       ¿
  36.     set entities(copy)      ⌐
  37.     set entities(ordf)      ¬
  38.     set entities(laquo)     ½
  39.     set entities(not)       ¼
  40.     set entities(shy)       ¡
  41.     set entities(reg)       «
  42.     set entities(macr)      »
  43.     set entities(deg)       ░
  44.     set entities(plusmn)    ▒
  45.     set entities(sup2)      ▓
  46.     set entities(sup3)      │
  47.     set entities(acute)     ┤
  48.     set entities(micro)     ╡
  49.     set entities(para)      ╢
  50.     set entities(middot)    ╖
  51.     set entities(cedil)     ╕
  52.     set entities(sup1)      ╣
  53.     set entities(ordm)      ║
  54.     set entities(raquo)     ╗
  55.     set entities(frac14)    ╝
  56.     set entities(frac12)    ╜
  57.     set entities(frac34)    ╛
  58.     set entities(iquest)    ┐
  59.     set entities(ntilde)    ±
  60.     set entities(Agrave)    └
  61.     set entities(Aacute)    ┴
  62.     set entities(Acirc)     ┬
  63.     set entities(Atilde)    ├
  64.     set entities(Auml)      ─
  65.     set entities(Aring)     ┼
  66.     set entities(AElig)     ╞
  67.     set entities(Ccedil)    ╟
  68.     set entities(Egrave)    ╚
  69.     set entities(Eacute)    ╔
  70.     set entities(Ecirc)     ╩
  71.     set entities(Euml)      ╦
  72.     set entities(Igrave)    ╠
  73.     set entities(Iacute)    ═
  74.     set entities(Icirc)     ╬
  75.     set entities(Iuml)      ╧
  76.     set entities(ETH)       ╨
  77.     set entities(Ntilde)    ╤
  78.     set entities(Ograve)    ╥
  79.     set entities(Oacute)    ╙
  80.     set entities(Ocirc)     ╘
  81.     set entities(Otilde)    ╒
  82.     set entities(Ouml)      ╓
  83.     set entities(times)     ╫
  84.     set entities(Oslash)    ╪
  85.     set entities(Ugrave)    ┘
  86.     set entities(Uacute)    ┌
  87.     set entities(Ucirc)     █
  88.     set entities(Uuml)      ▄
  89.     set entities(Yacute)    ▌
  90.     set entities(THORN)     ▐
  91.     set entities(szlig)     ▀
  92.     set entities(agrave)    α
  93.     set entities(aacute)    ß
  94.     set entities(acirc)     Γ
  95.     set entities(atilde)    π
  96.     set entities(auml)      Σ
  97.     set entities(aring)     σ
  98.     set entities(aelig)     µ
  99.     set entities(ccedil)    τ
  100.     set entities(egrave)    Φ
  101.     set entities(eacute)    Θ
  102.     set entities(ecirc)     Ω
  103.     set entities(euml)      δ
  104.     set entities(igrave)    ∞
  105.     set entities(iacute)    φ
  106.     set entities(icirc)     ε
  107.     set entities(iuml)      ∩
  108.     set entities(eth)       ≡
  109.     set entities(ntilde)    ±
  110.     set entities(ograve)    ≥
  111.     set entities(oacute)    ≤
  112.     set entities(ocirc)     ⌠
  113.     set entities(otilde)    ⌡
  114.     set entities(ouml)      ÷
  115.     set entities(divide)    ≈
  116.     set entities(oslash)    °
  117.     set entities(ugrave)    ∙
  118.     set entities(uacute)    ·
  119.     set entities(ucirc)     √
  120.     set entities(uuml)      ⁿ
  121.     set entities(yacute)    ²
  122.     set entities(thorn)     ■
  123.     set entities(yuml)       
  124.  
  125.     return
  126. }
  127.  
  128. ###############################################################################
  129. # ShowLinks
  130. #    Show the links found in the last preprocessed page, it's only good for
  131. #    debugging.
  132. ###############################################################################
  133. proc ShowLinks {} {
  134.     variable nLinks
  135.     variable links
  136.  
  137.     for {set i 1} {$i<$nLinks} {incr i} {
  138.         set description [TidyDescription $links($i,descrip) $links($i,url)]
  139.         if {[info exists links($i,type)]} {
  140.             puts "\n$i: $links($i,file) - Bajar: $links($i,ok)"
  141.             puts "$description - $links($i,type)"
  142.             puts "$links($i,url)"
  143.         } else {
  144.             puts "\n$i: $links($i,file) - Bajar: $links($i,ok)"
  145.             puts "$description"
  146.             puts "$links($i,url)"
  147.         }
  148.     }
  149.     return
  150. }
  151.  
  152. ###############################################################################
  153. # ParseUrl
  154. #    Given an url 'ParseUrl' will split it in its parts: protocol, domain,
  155. #    directory and filename
  156. #
  157. # Parameter
  158. #    The url to be parsed,
  159. #
  160. # Returns
  161. #    A list with the url split as mentioned above or '1' if the url couldn't be
  162. #    parsed.
  163. ###############################################################################
  164. proc ParseUrl {url} {
  165.  
  166.     if {[regexp -nocase \
  167.             {(([^:]*)(?:://))?([^/]+)(((?:~[^/]*)?(?:[^\?]*))(?:/)([^#]*))?} \
  168.             $url nada nada protocol domain nada dir fileName]} {
  169.         if {$protocol==""} {
  170.             set protocol http
  171.         }
  172.         return [list $protocol $domain $dir $fileName]
  173.     }
  174.  
  175.     return 1
  176. }
  177.  
  178. ###############################################################################
  179. # TidyDir
  180. #    Takes things like ".." and "." from the absolute path.
  181. #
  182. # Parameter:
  183. #    File path.
  184. #
  185. # Returns:
  186. #    The tidied file path.
  187. ###############################################################################
  188. proc TidyDir {path} {
  189.     if {[regexp {\.$} $path]} {
  190.         append path /
  191.     }
  192.     for {set a 1 ; set b 1} {($a>0)||($b>0)} {} {
  193.         set a [regsub -all {/\./} $path {/} path]
  194.         set b [regsub -all {([^./]+/\.\./)} $path {} path]
  195.     }
  196.     for {} {[regsub {^/\.\.} $path {} path]} {} {}
  197.  
  198.     return $path
  199. }
  200.  
  201. ###############################################################################
  202. # RemoveEntities
  203. #    Given a link or a link description, this procecedure subtitutes the
  204. #    Html character entities for the real thing, for example '&' gets
  205. #    changed to '&'.
  206. #
  207. # Parameter
  208. #    The string to process.
  209. #
  210. # Returns
  211. #    The string processed.
  212. ##############################################################################
  213. proc RemoveEntities {string} {
  214.     variable entities
  215.  
  216.     while {[regexp {(?:&)([^ ;]+)(;)?} $string old entity]} {
  217.         regsub {#} $entity {} entity
  218.         # Eventually this should be replaced with "string is number"
  219.         if {[regexp {^[0-9]+$} $entity]} {
  220.             if {[catch {format %c $entity} new]} {
  221.                 break
  222.             }
  223.             regsub -all {([\\])} $new {\\\1} new
  224.         } else {
  225.             if {[catch {set ::HtmlParser::entities($entity)} new]} {
  226.                 break
  227.             }
  228.         }
  229.         if {$new=="&"} {
  230.             set new "\\&"
  231.         }
  232.         regsub -all $old $string $new string
  233.     }
  234.     return $string
  235. }
  236.  
  237. ###############################################################################
  238. # TidyLinks
  239. #     Removes Html character entities from the links. It seems that if a
  240. #     file is, for example, called 'me&you.jpg' some webmasters or Html editors
  241. #     will put 'me&you.jpg' in the link.
  242. #
  243. # Side efects
  244. #     The links in 'links' will contain no character entities
  245. ################################################################################
  246. proc TidyLinks {} {
  247.     variable nLinks
  248.     variable links
  249.  
  250.     for {set i 1} {$i<$nLinks} {incr i} {
  251.         set links($i,file) [RemoveEntities $links($i,file)]
  252.     }
  253.     return
  254. }
  255.  
  256. ###############################################################################
  257. # TidyDescription
  258. #    Translates for human eyes the description of the links.
  259. #
  260. # Parameters:
  261. #    description: The description to be translated.
  262. #    url: The url for the translation
  263. #
  264. # Returns:
  265. #    The description translated.
  266. ###############################################################################
  267. proc TidyDescription {description url} {
  268.     global labelDialogs
  269.     variable entities
  270.     variable nLinks
  271.     variable links
  272.  
  273.     if {[regexp {^[\s]*$} $description]} {
  274.         return $url
  275.     }
  276.     if {[regexp -nocase {(<img)} $description]} {
  277.         regsub -all {<.*?>} $description {} tmp
  278.         if {![regexp {^\s*$} $tmp]} {
  279.             set description $tmp
  280.         } else {
  281.             set description [GetFileName $description alt]
  282.             if {$description==1} {
  283.                 set description $url
  284.             }
  285.             set description "$labelDialogs(linkImage): $description"
  286.         }
  287.     }
  288.     regsub -all {<.*?>} $description {} description
  289.  
  290.     set description [RemoveEntities $description]
  291.     regsub -all {\s+} $description { } description
  292.     regsub      {^\s} $description {}  description
  293.  
  294.     if {$description==""} {
  295.         return $url
  296.     }
  297.     return $description
  298. }
  299.  
  300. ###############################################################################
  301. # ChangeEncoding
  302. #    Changes the encoding in which the description of the links are written
  303. #
  304. # Parameters:
  305. #    newEncoding: The encoding to use.
  306. ###############################################################################
  307. proc ChangeEncoding {newEncoding} {
  308.     variable nLinks
  309.     variable links
  310.     global dirGetleft
  311.  
  312.     for {set i 1} {$i<$nLinks} {incr i} {
  313.         set links($i,descrip) \
  314.                 [encoding convertfrom "$newEncoding" $links($i,descrip)]
  315.     }
  316.  
  317.     return
  318. }
  319.  
  320. ###############################################################################
  321. # GetFileName
  322. #    Extrac the filename of the link, or the description in the 'alt' field
  323. #    from whatever it gets send.
  324. #
  325. # Parameter
  326. #    tag: the string to process.
  327. #    type: what we are looking for: "href", "src" or "alt".
  328. #
  329. # Returns:
  330. #    The filename or '1' if none was found.
  331. ###############################################################################
  332. proc GetFileName {tag type} {
  333.  
  334.     regsub -all {\s*=\s*} $tag {=} tag
  335.     if {[regexp -nocase -expanded [subst -nocommand {
  336.             (?:$type=) 
  337.             (?:(?:(?:\")([^\"]+))| # Filename between ""
  338.             (?:(?:\')([^\']+))|    # Between ''
  339.             ([^\ \"'>]+))          # No delimiter
  340.     }] $tag nada a b c]} {
  341.         if {$a!=""} {
  342.             set fileName $a
  343.         } elseif {$b!=""} {
  344.             set fileName $b
  345.         } elseif {$c!=""} {
  346.             set fileName $c
  347.         }
  348.         if {[regexp {^(&)(.*)(;)$} $fileName]} {
  349.             return 1
  350.         }
  351.         if {[regexp -nocase {^mailto:|^news:|^javascript:} $fileName]} {
  352.             return 1
  353.         }
  354.         # Workaround for Webmasters that don't know the directory separator 
  355.         # is a single / or feel like using the windows one \.
  356.         regsub -all {([^:])(//)|(\\)} $fileName {\1/} fileName
  357.         # It seems you can write a link as //site.com/file.html
  358.         regsub {^//} $fileName {http://} fileName
  359.         # The following is due to Javascript variables.
  360.         return $fileName
  361.     }
  362.     # If the link happens to be written like: <a href="">index.html</a>
  363.     if {[regexp -nocase [subst -nocommand {(?:$type=)((\"\")|(\'\'))}] $tag]} {
  364.         return ""
  365.     }
  366.     return 1
  367. }
  368.  
  369. ###############################################################################
  370. # CompleteString
  371. #    Reads from the channel 'leer' until the 'cosa' string includes the
  372. #    substring passed as a parameter. 
  373. #
  374. # Parameters:
  375. #    cadena: name of the variable with the string to complete.
  376. #    leer: channel to read from.
  377. #    pattern: substring to look for in the channel.
  378. #
  379. # Returns:
  380. #    - '0': No errors.
  381. #    - '1': The string could not be completed.
  382. #
  383. # Side efects:
  384. #    'cosa' is completed.
  385. ###############################################################################
  386. proc CompleteString {cadena leer pattern} {
  387.  
  388.     upvar $cadena cosa
  389.     while {![regexp -nocase [subst -nocommand {$pattern}] $cosa]} {
  390.         append cosa [read $leer 20]
  391.         if {[eof $leer]} {    
  392.             return 1
  393.         }
  394.     }
  395.     return 0
  396. }
  397.  
  398. ###############################################################################
  399. # Parsing
  400. #    Reads the Web page passed as a parameter and proccess it to extract
  401. #    all links.
  402. #
  403. # Parameters:
  404. #    file: File which contains the page to process.
  405. #    referer: The referer link for the page.
  406. #    level: The level in which we found the file to parse.
  407. #
  408. # Returns:
  409. #    - '0': No errors.
  410. #    - '1': Couldn't open file.
  411. #
  412. # Side efects:
  413. #    'nLinks': number of links plus one.
  414. #    'links' : keeps all the info about the links.
  415. ###############################################################################
  416. proc Parsing {file referer level} {
  417.     global   labelDialogs labelTitles getleftOptions
  418.     variable nLinks
  419.     variable links
  420.     variable pageEncoding
  421.     variable baseTag
  422.  
  423.     if {[string match $file ""]} return
  424.     set nLinks  1
  425.     catch {unset links}
  426.  
  427.     if {[catch {open $file r} leer]} {
  428.         return 1
  429.     }
  430.     catch {unset linkType}
  431.     set pageEncoding ""
  432.     for {set cosa ""; set thumbnailNext 0 ; set newBase "" ; set baseTag ""} \
  433.             {(![eof $leer]) || ([string compare $cosa ""])} {} {
  434.         if {$getleftOptions(pauseNow)==1} {
  435.             tkwait variable getleftOptions(pauseNow)
  436.         }
  437.         if {![regexp -nocase {((<)(a|b|l|i|f|s|m|t)(.*))|(<$)} $cosa cosa]} {
  438.             set cosa [read $leer 50] 
  439.             continue
  440.         }
  441.         set result [CompleteString cosa $leer ">"]
  442.         if {$result==1} break
  443.         regexp {(?:<)([^>]*)(?:>)(.*)} $cosa nada tag cosa
  444.  
  445.         set lowerTag [string tolower $tag]
  446.  
  447.         set fileName 1
  448.         switch -regexp $lowerTag {
  449.             "^area" {
  450.                 if {[set fileName [GetFileName $tag href]]!=1} {
  451.                     if {[set descrip [GetFileName $tag alt]]!=1} {
  452.                         set links($nLinks,descrip) $descrip
  453.                     } else {
  454.                         set links($nLinks,descrip) "$labelDialogs(map)"
  455.                     }
  456.                 }
  457.             }
  458.             "^a.+href" {
  459.                 if {[set fileName [GetFileName $tag href]]!=1} {
  460.                     if {[regexp -nocase {(javascript)(.*)(\()} $fileName]} continue
  461.                     # It so happens you can skip closing the link, browsers
  462.                     # consider them closed if you open another one.
  463.                     set result [CompleteString cosa $leer {(<)((/a)|(a))}]
  464.                     if {$result==1} break
  465.                     regexp -nocase {(.*?)(?:(<)((/a)|(a)))} $cosa nada descripcion
  466.                     set links($nLinks,descrip) $descripcion
  467.                     if {[string match $descripcion ""]} {
  468.                         set fileName 1
  469.                     }
  470.                     if {[regexp -nocase {<img[^>]* src} $descripcion]} {
  471.                         set thumbnailNext 1
  472.                     } else {
  473.                         regexp {(.*?)(<)} $descripcion descripcion
  474.                     }
  475.                 }
  476.             }
  477.             "^img" {
  478.                 if {[set fileName [GetFileName $tag src]]!=1} {
  479.                     if {[set descrip [GetFileName $tag alt]]==1} {
  480.                         set descrip $fileName
  481.                     }
  482.                     set links($nLinks,descrip) "$labelDialogs(image): $descrip"
  483.                     if {$thumbnailNext==0} {
  484.                         set links($nLinks,type) image
  485.                     } else {
  486.                         set links($nLinks,type) thumb
  487.                         set thumbnailNext 0
  488.                     }
  489.                 }
  490.             }
  491.             ^script {
  492.                 if {![regexp -nocase {/script>} $cosa]} {
  493.                     set result [CompleteString cosa $leer "/script>"]
  494.                     if {$result==1} break
  495.                 }
  496.                 regexp -nocase {(?:/script>)(.*)} $cosa nada cosa
  497.                 if {[set fileName [GetFileName $tag src]]!=1} {
  498.                     set links($nLinks,descrip) "Script: $fileName"
  499.                 }
  500.             }
  501.             "^frame" {
  502.                 if {[set fileName [GetFileName $tag src]]!=1} {
  503.                     set links($nLinks,descrip) "$labelDialogs(frame): $fileName"
  504.                 }
  505.             }
  506.             "^base" {
  507.                 if {[set fileName [GetFileName $tag href]]!=1} {
  508.                     set baseTag $tag
  509.                     set newBase [CompleteUrl $fileName $referer ""]
  510.                     set fileName 1
  511.                 }
  512.             }
  513.             "^link.+href" {
  514.                 if {[set fileName [GetFileName $tag href]]!=1} {
  515.                     set links($nLinks,descrip) "$labelDialogs(css)"
  516.                 }
  517.             }
  518.             ^meta {
  519.                 if {![regexp {(?:meta *)(?:charset=)(?:\"|')?([^\"' ]*)} $tag \
  520.                         nada pageEncoding]} {
  521.                     if {[set fileName [GetFileName $tag url]]!=1} {
  522.                         set links($nLinks,descrip)                            \
  523.                                 "$labelDialogs(relocation): $fileName"
  524.                     }
  525.                 }
  526.             }
  527.             ^table|^td|^th|^tr|^layer|^ilayer|^body {
  528.                 if {[set fileName [GetFileName $tag background]]!=1} {
  529.                     set links($nLinks,descrip) "$labelDialogs(image): $fileName"
  530.                 }
  531.             }
  532.  
  533.         }
  534.         if {$fileName!=1} {
  535. #           set newName $fileName
  536.             if {![regexp {^#} $fileName]} {
  537.                 set links($nLinks,file) $fileName
  538.                 set url [CompleteUrl $fileName $referer $newBase]
  539.                 set links($nLinks,url)  $url
  540.                 incr nLinks
  541.             }
  542.         }
  543.     }
  544.     close $leer
  545.     return 0
  546. }
  547.  
  548. ###############################################################################
  549. # FilterLinks
  550. #    Filters the links extracted from a page according to the rules given.
  551. #
  552. # Parameters
  553. #   referer: The url of the page we got the links from.
  554. #   linkArray: Name of the array where the links are stored
  555. #   level: The recursion level in which we found the referer.
  556. #   externalLevel: and the recursion level for links outside de domain.
  557. #
  558. # Side effects:
  559. #    'nLinks' and 'links' are upated to the new, filtered links
  560. ###############################################################################
  561. proc FilterLinks {referer linkArray level {externalLevel 0}} {
  562.     global downOptions siteUrl directories urlsDownloaded
  563.  
  564.     upvar #0 $linkArray links
  565.  
  566.     set baseSite $siteUrl(www)
  567.     regexp {(.*)(:)} $siteUrl(www)  nada baseSite
  568.  
  569.     for {set i 1} {[info exists links($i,url)]} {incr i} {
  570.         set link $links($i,url)
  571.         set links($i,ok) 1
  572.         if {([regexp {\.ram$} $link])} {
  573.             set links($i,ok) 0
  574.             continue
  575.         }
  576.         if {($downOptions(filter)!="")&&([regexp -nocase "$downOptions(filter)" \
  577.                 $links($i,file)])} {
  578.             set links($i,ok) 0
  579.             continue
  580.         }
  581.         if {([regexp {\?} $link])&&($downOptions(cgi)==0)} {
  582.             set links($i,ok) 0
  583.             continue
  584.         }
  585.         if {[info exists urlsDownloaded($link)]} {
  586.             set links($i,ok) 0
  587.             continue
  588.         }
  589.         if {[regexp {^ftp:.*/$} $link]} {
  590.             set links($i,ok) 0
  591.             continue
  592.         }
  593.         if {[regexp -nocase {^https://} $link]} {
  594.             set links($i,ok) 0
  595.             continue
  596.         }
  597.         set parsedUrl     [ParseUrl $link]
  598.         set protocol      [lindex $parsedUrl 0]
  599.         set direccion_www [lindex $parsedUrl 1]
  600.         set directory     [lindex $parsedUrl 2]
  601.         if {![info exists direccion_www]} {
  602.             set links($i,ok) 0 ; # Maybe something should be put in the error \
  603.                                    log about this.
  604.             continue
  605.         }
  606.         # www.domain.com and www.domain.com:8080 will be considered the
  607.         # same site.
  608.         set linkSite $direccion_www
  609.         regexp {(.*)(:)} $direccion_www nada linkSite
  610.         if {[string compare [string tolower $baseSite] \
  611.                     [string tolower $linkSite]]} {
  612.             if {$downOptions(exLevels)<=$externalLevel} {
  613.                set links($i,ok) 0
  614.                continue
  615.             }
  616.             set externalLink 1
  617.         } else {
  618.             set externalLink 0
  619.         }
  620.         if {($downOptions(dir)==0)&&($siteUrl(base)!="")&&($externalLink==0)} {
  621.             if {![regexp -nocase "^$siteUrl(base)" $directory]} {
  622.                 set links($i,ok) 0
  623.                 continue
  624.             }
  625.         }
  626.         if {($downOptions(levels)!=-1)&&($downOptions(levels)<=$level)} {
  627.             set links($i,ok) 0
  628.             continue
  629.         }
  630.  
  631.         set remove 0
  632.  
  633.         catch {
  634.             if {($links([expr {$i+1}],type)=="thumb")&&($downOptions(images)==1)} {
  635.                 if {[regexp -nocase {(gif$)|(jpg$)|(jpeg$)|(bmp$)|(xbm$)|(tiff$)|(png$)}\
  636.                         $links($i,file)]} {
  637.                     set remove 1
  638.                 }
  639.             }
  640.  
  641.         }
  642.         catch {
  643.             if {($links($i,type)=="thumb")&&($downOptions(images)==2)} {
  644.                 set remove 1
  645.             }
  646.         }
  647.         if {$remove==1} {
  648.             set links($i,ok) 0
  649.             continue
  650.         }
  651.     }
  652.     return
  653. }
  654.  
  655. ###############################################################################
  656. # CompleteUrl
  657. #    Given a link, this procedure returns the full Url of that link, for
  658. #    example, a link from a page may be '../index.html', this procedure
  659. #    will return something like 'http://www.algo.es/cosas/index.html'
  660. #
  661. # Parameter
  662. #    link: I'll let you guess
  663. #    referer: url of the referrer page for the link
  664. #    newBase: In case the page contains a 'BASE' tag, this will have the
  665. #             url to use as base for the links.
  666. #
  667. # Returns
  668. #    The url
  669. ###############################################################################
  670. proc CompleteUrl {link referer newBase} {
  671.     global siteUrl
  672.  
  673.     set link [RemoveEntities $link]
  674.     if {[regexp {://} $link]} {
  675.         # cgi links may have a http:// and still be relative
  676.         if {![regexp {(\?)(.*)(://)} $link]} {
  677.             return $link
  678.         }
  679.     }
  680.  
  681.     if {$newBase==""} {
  682.         set parsedUrl [ParseUrl $referer]
  683.     } else {
  684.         set parsedUrl [ParseUrl $newBase]
  685.     }
  686.  
  687.     set prot   [lindex $parsedUrl 0]
  688.     set domain [lindex $parsedUrl 1]
  689.     set dir    [lindex $parsedUrl 2]
  690.  
  691.     if {[regexp {(?::/)([^/].*)} $link nada fileName]} {
  692.         set url $prot://$domain/$fileName
  693.         return $url
  694.     }
  695.     if {[regexp {^/} $link]} {
  696.         set url $prot://$domain$link
  697.         return $url
  698.     }
  699.     set fileName [TidyDir $dir/$link]
  700.     set url "$prot://$domain$fileName"
  701.  
  702.     return $url
  703. }
  704.  
  705. SetEntities
  706.  
  707. }
  708.